perm filename ACS.OLD[1,LCS] blob
sn#086989 filedate 1974-02-07 generic text, type T, neo UTF8
00100 SUBROUTINE ACSHFT(RX)
00200 COMMON/SS/Y,RH,RN1 /XRN/RN(4000)
00500 COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
00600 1,DBST,NFLG,IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
00900 DIMENSION R(8,100)
01000 EQUIVALENCE (R,RN(3001))
01100 L=K-1
01200 M=L-ABS(RX)
01300 JD=1
01400 RN1=99
01500 CC RD=20
01600 Y=-.23
01700 IF(RX.LT.0)GO TO 1
01800 L=M
01900 M=K-1
02000 JD=-1
02100 CC RD=10
02200 1 DO 2 N=M,L,JD
02300 C DOES IT HAVE AN ACCID?
02400 IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
02410 X=0
02500 C IS THIS THE FIRST ACCID?
02600 IF(RN1.NE.99)GO TO 3
02700 RN1=R(4,N)
02800 GO TO 4
02900 3 RH=R(4,N)
03000 IF(ABS(RH-RN1).LT.5)GO TO 4
03100 RN1=RH
03200 Y=-.23
03300 CC GO TO 2
03350 4 CALL SHFT
03375 CC IF(Y.GE.1)Y=0
03400 IF((R(6,N+JD).EQ.20.OR.R(6,N-JD).EQ.20).AND.Y.EQ.0)CALL SHFT
03450 IF(R(6,N).EQ.10)X=.23
03500 IF(R(6,N).EQ.20.AND.Y.GE..23)Y=Y-.23
03600 CC IF(Y.GE.1.)Y=.23
03700 C SO Y DOESN'T GET >1.
03800 5 R(5,N)=R(5,N)+X+Y
03900 2 CONTINUE
04000 END
04100
04200 SUBROUTINE SHFT
04300 COMMON/SS/Y,RH,RN1
04400 Y=Y+.23
04500 IF(Y.LT.1)RETURN
04600 RN1=RH
04700 Y=0
04800 END